home *** CD-ROM | disk | FTP | other *** search
Visual Basic class definition | 1996-11-26 | 6.8 KB | 233 lines |
- VERSION 1.0 CLASS
- BEGIN
- MultiUse = -1 'True
- END
- Attribute VB_Name = "Rectangle"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = True
- Attribute VB_PredeclaredId = False
- Attribute VB_Exposed = False
- Option Explicit
- ' >> Best viewed in Full Module view. <<
- '
- ' Storage for debug ID number.
- Private mlngDebugID As Long
- Implements IDebug
-
- ' The Rectangle implements two interfaces;
- ' it also has one property (Filled) and
- ' one method (TimeTest) on its own
- ' interface.
-
- Implements IShape
- Implements Polygon
-
- ' The inner Polygon object actually holds
- ' the data and does some of the work.
- ' The Rectangle keeps references to both
- ' the Polygon interface and the IShape
- ' interface of the inner Polygon.
- Private mpyg As Polygon
- Private mish As IShape
-
- ' Storage for Color property (Polygon
- ' interface implementation).
- Private mrgbColor As Long
-
- ' Storage for the Filled property (on the
- ' Rectangle object's default interface).
- Private mblnFilled As Boolean
-
- ' -------------------------------------
- ' This is the beginning of Rectangle's
- ' implementation of the IShape
- ' interface.
-
- ' IShape.DrawToPictureBox is called to
- ' ------ ---------------- draw a shape,
- ' so each class of shape must supply
- ' its own implementation.
- '
- Private Sub IShape_DrawToPictureBox(ByVal pb As PictureBox)
- ' Instead of delegating to the IShape
- ' interface of the inner Polygon, the
- ' Rectangle takes advantage of the
- ' fact that there's a graphics command
- ' to draw a box in one operation
- ' instead of four (graphics being
- ' presumably the most time-consuming
- ' kind of operation).
- Dim sngX1 As Single, sngY1 As Single
- Dim sngX2 As Single, sngY2 As Single
- Call mpyg.GetPoint(0, sngX1, sngY1)
- Call mpyg.GetPoint(1, sngX2, sngY2)
- If mblnFilled Then
- pb.Line (sngX1, sngY1)-(sngX2, sngY2), mrgbColor, BF
- Else
- pb.Line (sngX1, sngY1)-(sngX2, sngY2), mrgbColor, B
- End If
- End Sub
-
- ' IShape.TimeTest method is used to show
- ' ====== -------- the reduced call
- ' overhead of a method called on an
- ' interface that several classes
- ' implement -- as opposed to calling
- ' a similar method on the classes'
- ' default interfaces.
- '
- Private Sub IShape_TimeTest()
- End Sub
-
- ' -------------------------------------
- ' This is the beginning of the implementation
- ' of the Polygon interface.
-
- ' Polygon.Color - Because the inner
- ' ======= ----- Polygon isn't used
- ' for drawing the Rectangle, the Color
- ' property is completely overridden.
- ' This is not required; the Rectangle
- ' could delegate storage of the Color
- ' property to the inner Polygon (as
- ' the Triangle class does), saving
- ' the implementation code and storage
- ' space. The color could then be
- ' retrieved from the inner Polygon
- ' when drawing is done.
- Private Property Get Polygon_Color() As Long
- Polygon_Color = mrgbColor
- End Property
- '
- Private Property Let Polygon_Color(ByVal RHS As Long)
- If 0 <> (RHS And &HFF000000) Then
- Err.Raise vbObjectError + 2080, , _
- "Invalid color value for Polygon."
- Exit Property
- End If
- mrgbColor = RHS
- End Property
-
- ' Polygon.TimeTest - Rectangle has three
- ' ======= -------- TimeTest methods, one
- ' on the IShape interface (used to show
- ' polymorphism and early binding), one on
- ' its own interface (used to show late
- ' binding), and this one. This one is
- ' a side effect of the fact that Rectangle
- ' implements the Polygon interface; it's
- ' not used for anything.
- Private Sub Polygon_TimeTest()
- End Sub
-
- ' Polygon.GetPoint
- ' ======= --------
- '
- Private Sub Polygon_GetPoint(ByVal intPoint As Integer, X As Single, Y As Single)
- ' Delegate to the inner Polygon.
- Call mpyg.GetPoint(intPoint, X, Y)
- End Sub
-
- ' Polygon.GetPointCount
- ' ======= -------------
- '
- Private Property Get Polygon_GetPointCount() As Integer
- ' There's no point in delegating to
- ' the inner Polygon, because the
- ' Rectangle is always specified by
- ' just two points.
- Polygon_GetPointCount = 2
- End Property
-
- ' Polygon.SetPoints - When implementing the
- ' ======= --------- SetPoints method
- ' of the Polygon interface, the Rectangle
- ' executes its own code to verify that
- ' the input array contains only two
- ' points (four Singles), and then
- ' delegates to the inner Polygon
- ' object.
- Private Sub Polygon_SetPoints(asngPoints() As Single)
- Dim blnBadArray As Boolean
- On Error Resume Next
- ' Ensure that the input array contains
- ' no more than four points. (The
- ' Polygon's SetPoint method will
- ' verify that the array is zero-
- ' based.)
- If UBound(asngPoints) <> 3 Then blnBadArray = True
- ' If an error occurred calling UBound,
- ' reject the array.
- If Err.Number <> 0 Then blnBadArray = True
- If blnBadArray Then
- Err.Raise vbObjectError + 2083, , _
- "A rectangle is specified by an array of four numbers (left, top, right, bottom) in a zero-based array."
- Exit Sub
- End If
- ' Delegate to the inner Polygon, which
- ' completes validation of the array
- ' and stores it.
- Call mpyg.SetPoints(asngPoints)
- End Sub
-
- ' --------------------------------------
- ' This is the beginning of the Rectangle
- ' object's own (default) interface.
-
- ' TimeTest method takes no
- ' -------- arguments, and
- ' immediately returns. It's used to
- ' illustrate late binding, as opposed
- ' to the early binding provided by
- ' calling TimeTest on the IShape
- ' interface.
- Public Sub TimeTest()
- End Sub
-
- ' Filled property determines whether a
- ' ------ rectangle is filled when
- ' drawn.
- Public Property Get Filled() As Boolean
- Filled = mblnFilled
- End Property
- '
- Public Property Let Filled(ByVal NewValue As Boolean)
- mblnFilled = NewValue
- End Property
-
- ' --------------------------------------
- ' This is the beginning of the class's
- ' private procedures (helper procedures
- ' and event procedures).
-
- Private Sub Class_Initialize()
- Dim asngPoints(0 To 3) As Single
- ' Debug code.
- mlngDebugID = DebugInit(Me)
- '
- ' Create the inner Polygon object, and
- ' get a reference to its IShape
- ' interface.
- Set mpyg = New Polygon
- Set mish = mpyg
- ' Initialize the inner Polygon.
- Call mpyg.SetPoints(asngPoints)
- End Sub
-
- Private Sub Class_Terminate()
- DebugTerm Me
- End Sub
-
- ' -------- IDebug Implementation --------
- '
- ' IDebug.DebugID gives you a way to tell
- ' ====== ------- objects apart. It's
- ' required by the DebugInit, DebugTerm,
- ' and DebugShow debugging procedures
- ' declared in modFriend.
- '
- Private Property Get IDebug_DebugID() As Long
- IDebug_DebugID = mlngDebugID
- End Property
-
-